(setenv "WOOF_MODULES" "c:/my_system/src/misc/woof/trunk/kernel")

(define resolve-woof-file
  (lambda (file)
    (let ((in-modules (string-append (getenv "WOOF_MODULES") "/" file))
	  (in-cwd (string-append "./" file)))
      (cond ((file-exists? in-cwd) in-cwd)
	    ((file-exists? in-modules) in-modules)
	    (else (raise (string-append "File could not be found: " file)))))))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; state manipulation/access functions ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define activate-block-context!
  (lambda (context state)
    (machine-state-active-context-set! state context)))

(define top-of-stack
  (lambda (state)
    (first (machine-state-stack state))))

(define top-n-of-stack
  (lambda (n state)
    (take (machine-state-stack state) n)))

(define pop-n-of-stack!
  (lambda (n state)
    (let ((result (take (machine-state-stack state) n)))
      (do ((i 0 (+ i 1)))
	  ((= i n))
	(pop-stack! state))
      result)))

(define push-stack!
  (lambda (val state)
    (let* ((context (machine-state-active-context state))
	   (stack (block-context-stack context)))
      (block-context-stack-set! context (cons val stack)))))

(define pop-stack!
  (lambda (state)
    (let* ((context (machine-state-active-context state))
	   (stack (block-context-stack context))
	   (val (first stack)))
      (block-context-stack-set! context (cdr stack))
      val)))

(define inc-pc!
  (lambda (state)
    (let* ((context (machine-state-active-context state))
	   (pc (block-context-pc context)))
      (block-context-pc-set! context (+ 1 pc)))))

(define current-instr
  (lambda (state)
    (instr-at (machine-state-code state)
	      (machine-state-pc state))))

(define opcode
  (lambda (instr)
    (first instr)))

(define arg1
  (lambda (instr)
    (second instr)))

(define arg2
  (lambda (instr)
    (third instr)))

(define instr-at
  (lambda (code i)
    (list-ref code i)))

(define env-var-set!
  (lambda (state i j obj)
    (let* ((context (machine-state-active-context state))
	   (env (block-context-env context))
	   (target-context (list-ref env i))
	   (target-frame (block-context-tmps target-context)))
      (if (>= j (vector-length target-frame))
	  (block-context-tmps-set! target-context (vector-append 
						   target-frame 
						   '#(0 0 0 0 0 0 0))))
      (vector-set! (block-context-tmps target-context) j obj))))


(define env-get-var
  (lambda (state i j)
    (let* ((context (machine-state-active-context state))
	   (env (block-context-env context))
	   (target-context (list-ref env i))
	   (target-frame (block-context-tmps target-context)))
      (vector-ref target-frame j))))

(define machine-state-env
  (lambda (state)
    (block-context-env (machine-state-active-context state))))


(define add-block-context-exception-handler!
  (lambda (handler context state)
    (block-context-exception-handlers-set!
     context
     (cons handler (block-context-exception-handlers context)))))


(define print-env
  (lambda (env)
    (map (lambda (ea) (begin (display "(")
			     (vector-for-each
			      (lambda (var)
				(if (woof-object? var)
				    (print-woof-object var)))
			      (block-context-tmps ea))
			     (display ")")))
	 env)))


(define machine-state-stack
  (lambda (state)
    (block-context-stack (machine-state-active-context state))))

(define machine-state-pc
  (lambda (state)
    (block-context-pc (machine-state-active-context state))))

(define machine-state-pc-set!
  (lambda (state pc)
    (let ((context (machine-state-active-context state)))
      (block-context-pc-set! context pc))))

(define machine-state-code
  (lambda (state)
    (woof-block-object-code
     (block-context-block
      (machine-state-active-context state)))))

(define print-woof-object
  (lambda (o)
    (display "<a ")
    (display (woof-class-object-name (woof-object-class o)))
;;    (if (woof-object-prim-data o) (begin
;;				    (display " - ")
;;				    (print (woof-object-prim-data o))))
    (display ">")))


(define nil?
  (lambda (object state)
    (eq? object (global-by-name "nil" (machine-state-globals state)))))

(define not-nil?
  (lambda (object state)
    (not (eq? object (global-by-name "nil" (machine-state-globals state))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;
;; state initialization ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;


(define new-top-level-machine-state
  (lambda (#!key (globals (init-woof-globals! (new-woof-globals))) (code '()))
    (let* ((state (new-machine-state
		   globals: globals))
	   (block (new-top-level-block state code))
	   (context (new-top-level-context-for-block state block)))
      (machine-state-active-context-set! state context)
      state)))


(define call-with-new-woof-state
  (lambda (func)
    (let (state (new-top-level-machine-state))
      (func state))))


;; Activate 'block' as root of a new block-context chain
(define new-top-level-context-for-block
  (lambda (state block)
    (let* ((globals (machine-state-globals state))
	   (tmps (make-vector 0))
	   (new-context (new-block-context
			 pc: (woof-block-object-code-pc block)
			 block: block
			 stack: '()
			 sender: (woof-nil globals)
			 home: (woof-nil globals)
			 tmps: tmps)))
      (woof-block-object-home-set! block new-context)
      (block-context-env-set! new-context (list new-context))
      new-context)))


(define new-context-for-block
  (lambda (block args state)
    (let* ((num-args (length args))
	   (home (woof-block-object-home block))
	   (tmps (let ((tmps (make-vector num-args)))
		   (do ((i 0 (+ i 1)))
		       ((= i num-args))
		     (vector-set! tmps i (list-ref args i)))
		   tmps
		   ))
	   (new-context (new-block-context
			 pc: (woof-block-object-code-pc block)
			 block: block
			 stack: '()
			 sender: (machine-state-active-context state)
			 home: home
			 tmps: tmps)))
      (block-context-env-set! new-context
			      (cons new-context (block-context-env home)))
      new-context)))



(define init-proto-globals!
  (lambda (globals)
    (let ((nil (new-woof-class-object
		name: "nil"
		))
	  (metaclass (new-woof-class-object
		      name: "MetaClass"
		      ))
	  )
      (woof-class-object-super-set! nil nil)
      (woof-object-class-set! nil nil)
      (install-class! nil globals)
      (install-global! nil "nil" globals)
      (woof-class-object-super-set! metaclass nil)
      (woof-object-class-set! metaclass metaclass)
      (install-class! metaclass globals)
      globals)))

(define init-woof-globals!
  (lambda (globals)
    (init-proto-globals! globals)
    (let ((nil (class-by-name "nil" globals))
	  (metaclass (class-by-name "MetaClass" globals)))

      (install-class! (create-class "Class" nil globals) globals)
      (install-class! (create-class "Object" nil globals) globals)
      ;;Set MetaObject's super to Class
      (woof-class-object-super-set!
       (woof-object-class (class-by-name "Object" globals))
       (class-by-name "Class" globals))
      (install-class! (create-class "String" (class-by-name "Object" globals) globals)
		      globals)
      (install-class! (create-class "Integer" (class-by-name "Object" globals) globals)
		      globals)
      (install-class! (create-class "List" (class-by-name "Object" globals) globals)
		      globals)
      (install-class! (create-class "Function" (class-by-name "Object" globals) globals)
		      globals)
      (install-class! (create-class "Block" (class-by-name "Object" globals) globals)
		      globals)
      (install-class! (create-class "Continuation" (class-by-name "Object" globals) globals)
		      globals)
      (install-class! (create-class "Exception" (class-by-name "Object" globals) globals)
		      globals)
      (install-class! (create-class "Boolean" (class-by-name "Object" globals) globals)
		      globals)
      (install-class! (create-class "True" (class-by-name "Boolean" globals) globals)
		      globals)
      (install-class! (create-class "False" (class-by-name "Boolean" globals) globals)
		      globals)
      
      (install-global! (woof-instance (class-by-name "False" globals)) "false" globals)
      (install-global! (woof-instance (class-by-name "True" globals)) "true" globals)
      
      (install-class! (create-class "Maybe" (class-by-name "Object" globals) globals)
		      globals)
      
      (install-class! (create-class "Just" (class-by-name "Maybe" globals) globals)
		      globals)
      
      (install-class! (create-class "Nothing" (class-by-name "Maybe" globals) globals)
		      globals)        
      
      (install-class! (create-class "Port" (class-by-name "Object" globals) globals)
		      globals)
      (install-class! (create-class "OutputPort" (class-by-name "Port" globals) globals)
		      globals)
      (let ((stdout (woof-instance (class-by-name "OutputPort" globals))))
	(woof-object-prim-data-set! stdout (current-output-port))
	(install-global! stdout "STDOUT" globals))
      
      (install-function! (new-woof-function-object
			  sig: "define:over:as:"
			  specs: (list (class-by-name "String" globals)
				       (class-by-name "List" globals)
				       (class-by-name "Block" globals))
			  block: (new-woof-block-object
				  globals
				  code: '((LVAR 0 0)
					  (LVAR 0 1)
					  (LVAR 0 2)
					  (CRFN)
					  (GETC "nil")
					  (RETURN)
					  )
				  code-pc: 0)
			  ) globals)
      
      (install-function! (new-woof-function-object
			  sig: "require:"
			  specs: (list (class-by-name "String" globals))
			  block: (new-woof-block-object
				  globals
				  code: '((LVAR 0 0)
					  (PRIM "load_block_from_file")
					  (CALLJ 0)
					  (GETC "nil")
					  (RETURN)
					  )
				  code-pc: 0)
			  ) globals)
      
      globals
      )))


;;;;;;;;;;;;;;;;;;;;;;;;;;
;; function dispatching ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

(define functions-by-sig
  (lambda (sig globals)
    (table-ref (woof-globals-functions globals) sig '())))



(define applicable-functions
  (lambda (s-sig s-args globals)

    (let ((arg-classes
	   (map (lambda (ea) (woof-object-class ea))
		s-args)))
      (sort-functions-by-specificity
       (filter (lambda (f)
		 (every (lambda (pair) (class-conforms? (first pair) (second pair ) globals))
			(zip arg-classes (woof-function-object-specs f))))
	       (functions-by-sig s-sig globals))))))

;; Check if c1 is a subtype of c2 or equal to c2
(define class-conforms?
  (lambda (c1 c2 globals)
    (or (eq? c1 c2)
	(let ((c1-super (woof-class-object-super c1)))
	  (if (not (eq? c1 (class-by-name "nil" globals)))
	      (class-conforms? c1-super c2 globals)
	      #f)))))

(define class-more-specific?
  (lambda (c1 c2)
    (> (length (woof-class-object-super-list c1))
       (length (woof-class-object-super-list c2)))))

;; sorts the funcs from most specific to least specific
(define sort-functions-by-specificity
  (lambda (funcs)
    (quicksort funcs (lambda (f1 f2)
		       (any (lambda (c1 c2)
			      (class-more-specific? c1 c2))
			    (woof-function-object-specs f1)
			    (woof-function-object-specs f2))))))


;;;;;;;;;;;;;;;;;;;;;;;;
;; exception handling ;;
;;;;;;;;;;;;;;;;;;;;;;;;

;; Starting at active-context, search down the sender chain for the first
;; applicable exception handler.
(define next-handler
  (lambda (exception-object state)
    (let* ((exception-class (woof-object-class exception-object)))
      (letrec ((find-handler
		(lambda (context)
		  (let ((handler (applicable-handler exception-class context state))
			(next-context (block-context-sender context)))
		    (if handler
			handler
			(if (block-context? next-context)
			    (find-handler next-context)
			    (raise 'no-exception-handler-found)))
		    ))))
	(find-handler (machine-state-active-context state))))))


;; If context has an exception handler appropriate for exception-class,
;; return it. Otherwise, #f
(define applicable-handler
  (lambda (exception-class context state)
    (let ((handlers (block-context-exception-handlers context)))
      (if (> (length handlers) 0)
	  (first handlers)
	  #f))))

(define raise-exception!
  (lambda (e state)
    (let* ((handler (next-handler e state))
	   (handler-block (exception-handler-handler-block handler))
	   (handler-sender (block-context-sender (exception-handler-context handler)))
	   (handler-context (new-context-for-block
			     handler-block
			     (list e)
			     state)))
      (block-context-sender-set! handler-context handler-sender)
      (activate-block-context! handler-context state))))



  ;;;;;;;;;;;;;;;;;;
;; continations ;;
  ;;;;;;;;;;;;;;;;;;


(define copy-block-context-for-continuation
  (lambda (context)
    (let* ((sender (block-context-sender context))
	   (home (block-context-home context)))
      (make-block-context
       (block-context-pc context)
       (block-context-block context)
       (list-copy (block-context-stack context))
       (if (block-context? sender)
	   (copy-block-context-for-continuation sender)
	   sender)
       (if (block-context? home)
	   (copy-block-context-for-continuation home)
	   home)
       (block-context-tmps context)
       (list-copy (block-context-env context))
       (list-copy (block-context-exception-handlers context))
       ))))
